module Main where
import Network
import System.IO
import System.Random
import System.Time
import System.Directory
import System.FilePath
import Control.Concurrent
import Control.Monad
import Control.Monad.Error
import Data.List
import Data.IORef
import Data.Time.Clock
import Salsa.Types
import Salsa.Interpreter
import Salsa.Primitives
import Salsa.Parser
import ExtPostAndGet
import ExtHeaders
import Control.Exception hiding (catch)
import qualified Data.HashTable as Hash
import Database.HSQL.SQLite3 (connect)
import Database.HSQL
import Database.HSQL.Types


type SessionTable = Hash.HashTable Int Session
data Session = Session {lastActive :: IORef ClockTime, values :: (Hash.HashTable String Exp)}

main = do conf <- readConf
          sesstable <- newSessionTable
          withSocketsDo $ bracket (listenOn $ PortNumber $ fromIntegral $ port conf)
                            (sClose)
                            (serverLoop sesstable conf)
root xs = let r = (!! 0) xs in r ++ "/"
port = read . (!! 1) :: [String] -> Integer
expire = read . (!! 2) :: [String] -> Int
db = (!! 3)

serverLoop sesstable conf sock = accept sock >>= 
                                 answer >> clean sesstable (expire conf) >> 
                                 serverLoop sesstable conf sock
    where answer (h,_,_) = 
              forkIO $ do hSetBuffering h (BlockBuffering (Just 1048576))
                          readHttp h [] >>= (http h conf sesstable)  . map words
                          hClose h

readConf = do confFile <- readFile "conf"
              let conf = read confFile :: [(String,String)]
                  port = maybe (1729) (read) (lookup "port" conf) :: Integer
                  root = maybe ("")  (flip const []) (Data.List.lookup "root" conf)
                  expr = maybe (60) (read) (lookup "expire" conf) :: Integer
                  db   = maybe ("lambada") (flip const []) (Data.List.lookup "db" conf)
              putStrLn $ "Celia is listening on port: " ++ show port
              putStrLn $ "using " ++ root ++ " as root"
              putStrLn $ "sessions expire in " ++ show expr ++ " minutes"
              putStrLn $ "Using db: " ++ db
              putStrLn $ "Let's dance!"
              return [root, show port, show expr, db]
          
http :: Handle -> [String] -> SessionTable -> [[String]] -> IO ()
http h conf sesstable req@(["GET",name,_]:_) =
       genResponse h conf sesstable req

http h conf sesstable req@(["POST",name,_]:_) =
    genResponse h conf sesstable req

http h _  _ req@([_, _, _]:_) =
     do hPutStr h page405 -- Method not allowed

http h _  _ req = 
    do hPutStr h page400 -- Bad Request

genResponse h conf sesstable req@([method,name,_]:rest) =
 do let withNewCookie = do session <- newSession
                           id <- genID
                           Hash.insert sesstable id session
                           response <- catch (processFile session resource conf params [("Set-cookie", show id)])
                                             (\e -> return $ page404 ++ "\nError: " ++ show e)
                           hPutStr h response
    case getHeaderValue (map unwords rest) "Cookie: " of
         Just id -> do maybeSess <- Hash.lookup sesstable (read id)
                       case maybeSess of
                         Just session -> do response <- catch (processFile session resource conf params [])
                                                              (\e -> return $ page404 ++ "\nError: " ++ show e)
                                            hPutStr h response
                         Nothing -> withNewCookie
         Nothing -> withNewCookie
    where resource = case method of
                       "GET"  -> (root conf) ++ (drop 1 $ relPath name)
                       "POST" -> (root conf) ++ (drop 1 name)
          params = case method of
                     "GET"  -> get name
                     "POST" -> post rest

processFile session name conf params hdrs =
    if isMambo name || isMerengue name
    then do result <-  runErrorT $ interpretFile session name conf params hdrs
            case result of
              Left err -> return (page500 ++ show err)
              Right html -> do return (page200 ++ (fileType name) ++ html)
    else readFile name >>= \conts ->  (return (page200 ++ (fileType name) ++ "\n\n" ++ conts))

interpretFile :: Session -> String -> [String] -> [(String,String)] -> [(String, String)] -> IOThrowsError String
interpretFile session name conf params hdrs = 
    do env <- liftIO $ primitiveEnv
       liftIO $ defineVar env "params" $ List $ map (toDotList) params
       liftIO $ defineVar env "hdrs" $ List $ map (toDotList) hdrs
       liftIO $ defineVar env "get-session-value" $ IOFun (gsv session)
       liftIO $ defineVar env "set-session-value" $ IOFun (ssv session)
       liftIO $ defineVar env "root" $ String $ (root conf)
       liftIO $ defineVar env "set-persistent" $ IOFun (setPersistent (db conf))
       liftIO $ defineVar env "get-persistent" $ IOFun (getPersistent (db conf))
       (liftIO $ openFile "Celia.sl" ReadMode) >>= \h -> hEval env h "Celia.sl"
       case takeExtension name of
         ".mrn" -> (liftIO . readFile) name >>= (toHTML env) >>= return
         ".mbo" -> do h <- (liftIO $ openFile name ReadMode) 
                      exec <- liftIO $ runErrorT $ hEval env h name 
                      case exec of
                        Left err -> throwError err
                        Right val -> return $ prettyPrint val

readHttp :: Handle -> [String] -> IO [String]
readHttp h acc = do str <- liftM  words $ hGetLine h
                    case str !! 0 of
                       "GET" -> loopGet h [unwords str]
                       "POST" -> loopPost h [unwords str]
    where loopGet,loopPost :: Handle -> [String] -> IO [String]
          loopGet h acc =
                    do str <- hGetLine h
                       if str == "\r"
                        then return (reverse acc)
                        else loopGet h (str : acc)
          
          loopPost h acc = do str <- hGetLine h
                              if str == "\r"
                               then case getHeaderValue acc "Content-Length:" of
                                      Nothing -> return ("BadRequest" : acc)
                                      Just n -> do post <- hGetCharN h (read n)
                                                   return $ reverse (post : acc) 
                               else loopPost h (str : acc)

page200 = "HTTP/1.0 200 OK\nContent-type: "
page404 = "HTTP/1.0 404 Not Found\nContent-type: text/html\n\n<h1>Error 404 Page not found</h1>\n The page you have requested has not been found!"
page405 = "HTTP/1.0 405 Method Not Allowed\nContent-type: text/html\nAllowed: GET, POST\n\n<h1>Error 405 Method not allowed</h1>\n The method you have requested is not allowed!"
page500 = "HTTP/1.0 500 Internal Server Error\nContent-type: text/html\n\n<h1>Error 500 Internal Server Error </h1>\n"
page400 = "HTTP/1.0 400 Bad Request\n\nBadRequest"

extensions :: [(String,String)]
extensions = [(".html", "text/html")
              ,(".png", "image/png")
              ,(".jpg", "image/jpg")
              ,(".gif", "image/gif") 
              ,(".mrn", "text/html")
              ,(".mbo", "text/html")
             ] 

fileType name = maybe ("text/plain") (flip const []) 
           (lookup (takeExtension name) extensions)

getHeaderValue :: [String] -> String -> Maybe String
getHeaderValue xs hdr = find (isPrefixOf hdr) xs >>= stripPrefix' hdr

stripPrefix' :: Eq a => [a] -> [a] -> Maybe [a]
stripPrefix' [] ys = Just ys
stripPrefix' (x:xs) (y:ys)
 | x == y = stripPrefix' xs ys
stripPrefix' _ _ = Nothing
 
hGetCharN :: Handle -> Integer -> IO [Char]
hGetCharN h n = loop h n 
    where loop :: Handle -> Integer -> IO [Char]
          loop _ 0 = return []
          loop h n = do c <- hGetChar h  
                        cs <- loop h (n - 1)
                        return (c:cs) 

toDotList :: (String,String) -> Exp
toDotList param = DotList [(String . fst) param] $ (String . snd) param

-------------------------------------
-- Salsa DB Primitives
-------------------------------------

setPersistent :: String -> [Exp] -> IOThrowsError Exp
setPersistent db [String name, value] = spersistent db name $ show value
{-
setPersistent db [String name, List value] = spersistent db name (show value)
setPersistent db [String name, String value] = spersistent db name value
setPersistent db [String name, Integer value] = spersistent db name (show value)
setPersistent db [String name, DotList value value'] = spersistent db name (show value ++ show value')
setPersistent db [String name, Bool value] = spersistent db name (show value)
-}
setPersistent db args@[_,_] = throwError $ TypeMismatch "Expectind a string and a salsa value, found: " (List args) "set-persistent"
setPersistent _ badArg = throwError $ NumArgs 2 badArg "set-persistent"

spersistent :: FilePath -> String -> String -> IOThrowsError Exp
spersistent db name value = 
    do c <- liftIO $ connect db AppendMode 
       let q = "INSERT INTO salsavalues (id, val) VALUES('" ++ name ++ "', '" ++ value ++ "')" 
        in do liftIO $ query c q 
              liftIO $ disconnect c
              liftThrows (Salsa.Parser.readExp value)

getPersistent :: String -> [Exp] -> IOThrowsError Exp
getPersistent db [String name] = 
    do c <- liftIO $ connect db ReadMode
       stmt <- liftIO $ query c q 
       liftIO $ fetch stmt
       value <- liftIO $ getFieldValue stmt "val" 
       liftIO $ closeStatement stmt
       liftIO $ disconnect c
       return (String value)
       where q = "SELECT * FROM salsavalues WHERE id = '" ++ name ++ "'"
getPersistent db args@[_] = throwError $ TypeMismatch "Expectind a string, found: " (List args) "get-persistent"
getPersistent _ badArg = throwError $ NumArgs 1 badArg "get-persistent"
             
------------------------------------
-- Session Helpers
------------------------------------

newSessionTable :: IO SessionTable
newSessionTable = (Hash.new (==) Hash.hashInt)

newSession :: IO Session
newSession = 
    do now <- getClockTime
       created <- newIORef now
       table <- (Hash.new (==) Hash.hashString)
       return (Session created table)

genID :: IO Int
genID = getStdRandom (randomR (1, 99999999999999999999999999))

gsv :: Session -> [Exp] -> IOThrowsError Exp
gsv session@(Session _ table) [String k] = 
    do liftIO $ updateClock session
       maybeVal <- liftIO $ Hash.lookup table k
       case maybeVal of
         Just a -> return a
         Nothing -> return $ List $ []
gsv _ other = throwError $ TypeMismatch "Expecting string, found " (List other) "get-session-value"

ssv :: Session -> [Exp] -> IOThrowsError Exp
ssv session@(Session _ table) [String k, val] = 
    do liftIO $ updateClock session
       liftIO $ Hash.update table k val
       return val
ssv _ other = throwError $ TypeMismatch "Expecting string and a value, found " (List other) "set-session-value"

updateClock :: Session -> IO ()
updateClock (Session last _) =
    do now <- liftIO $ getClockTime
       liftIO $ writeIORef last now

clean :: SessionTable -> Int -> IO ()
clean sesstable expire = 
    do table <- Hash.toList sesstable
       now <- getClockTime
       expiredSessions <- filterM (expired now) table
       mapM_ (Hash.delete sesstable) (map getID expiredSessions) where
           expired :: ClockTime -> (Int, Session) -> IO Bool
           expired now (_, Session la _) = 
               do lastActive <- readIORef la
                  return $ tdMin (diffClockTimes now lastActive) > expire
           getID (sessid,_) = sessid
          